home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2000 #5 / Amiga Plus CD - 2000 - No. 5.iso / Tools / Dev / fpc / units / sysamiga.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-10-28  |  54.4 KB  |  1,876 lines
  1. {
  2.     $Id: sysamiga.pas,v 1.9 1998/08/17 12:34:22 carl Exp $
  3.     This file is part of the Free Pascal run time library.
  4.     Copyright (c) 1993,98 by Carl Eric Codere
  5.     Some parts taken from
  6.        Marcel Timmermans - Modula 2 Compiler
  7.        Nils Sjoholm - Amiga porter
  8.        Matthew Dillon - Dice C (with his kind permission)
  9.           dillon@backplane.com
  10.  
  11.     See the file COPYING.FPC, included in this distribution,
  12.     for details about the copyright.
  13.  
  14.     This program is distributed in the hope that it will be useful,
  15.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  16.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  17.  
  18.  **********************************************************************}
  19. unit sysamiga;
  20.  
  21. {--------------------------------------------------------------------}
  22. { LEFT TO DO:                                                        }
  23. {--------------------------------------------------------------------}
  24. { o GetDir with different drive numbers                              }
  25. {--------------------------------------------------------------------}
  26.  
  27. {$I os.inc}
  28.  
  29. { AmigaOS uses character #10 as eoln only }
  30. {$DEFINE SHORT_LINEBREAK}
  31.  
  32.   interface
  33.  
  34.     { used for single computations }
  35.     const BIAS4 = $7f-1;
  36.  
  37.     {$I systemh.inc}
  38.  
  39.     {$I heaph.inc}
  40.  
  41. const
  42.   UnusedHandle    : longint = -1;
  43.   StdInputHandle  : longint = 0;
  44.   StdOutputHandle : longint = 0;
  45.   StdErrorHandle  : longint = 0;
  46.  
  47.  _ExecBase:longint = $4;
  48.  _WorkbenchMsg : longint = 0;
  49.  
  50.  _IntuitionBase : pointer = nil;       { intuition library pointer }
  51.  _DosBase       : pointer = nil;       { DOS library pointer       }
  52.  _UtilityBase   : pointer = nil;       { utiity library pointer    }
  53.  
  54.  { Required for crt unit }
  55.   function do_read(h,addr,len : longint) : longint;
  56.   function do_write(h,addr,len : longint) : longint;
  57.  
  58.  
  59.  
  60.  
  61.  
  62.   implementation
  63.  
  64.  const
  65.  
  66.    intuitionname : pchar = 'intuition.library';
  67.    dosname : pchar = 'dos.library';
  68.    utilityname : pchar = 'utility.library';
  69.    argc : longint = 0;
  70.    { AmigaOS does not autoamtically deallocate memory on program termination }
  71.    { therefore we have to handle this manually. This is a list of allocated  }
  72.    { pointers from the OS, we cannot use a linked list, because the linked   }
  73.    { list itself uses the HEAP!                                              }
  74.    pointerlist : array[1..8] of longint =
  75.     (0,0,0,0,0,0,0,0);
  76.  
  77.  
  78.     {$I exec.inc}
  79.  
  80.   TYPE
  81.     TDateStamp = packed record
  82.         ds_Days         : Longint;      { Number of days since Jan. 1, 1978 }
  83.         ds_Minute       : Longint;      { Number of minutes past midnight }
  84.         ds_Tick         : Longint;      { Number of ticks past minute }
  85.     end;
  86.     PDateStamp = ^TDateStamp;
  87.  
  88.  
  89.     PFileInfoBlock = ^TfileInfoBlock;
  90.     TFileInfoBlock = packed record
  91.         fib_DiskKey     : Longint;
  92.         fib_DirEntryType : Longint;
  93.                         { Type of Directory. If < 0, then a plain file.
  94.                           If > 0 a directory }
  95.         fib_FileName    : Array [0..107] of Char;
  96.                         { Null terminated. Max 30 chars used for now }
  97.         fib_Protection  : Longint;
  98.                         { bit mask of protection, rwxd are 3-0. }
  99.         fib_EntryType   : Longint;
  100.         fib_Size        : Longint;      { Number of bytes in file }
  101.         fib_NumBlocks   : Longint;      { Number of blocks in file }
  102.         fib_Date        : TDateStamp; { Date file last changed }
  103.         fib_Comment     : Array [0..79] of Char;
  104.                         { Null terminated comment associated with file }
  105.         fib_Reserved    : Array [0..35] of Char;
  106.     end;
  107.  
  108.  
  109.     TProcess = packed record
  110.         pr_Task         : TTask;
  111.         pr_MsgPort      : TMsgPort;      { This is BPTR address from DOS functions  }
  112. {126}   pr_Pad          : Word;         { Remaining variables on 4 byte boundaries }
  113. {128}   pr_SegList      : Pointer;      { Array of seg lists used by this process  }
  114. {132}   pr_StackSize    : Longint;      { Size of process stack in bytes            }
  115. {136}   pr_GlobVec      : Pointer;      { Global vector for this process (BCPL)    }
  116. {140}   pr_TaskNum      : Longint;      { CLI task number of zero if not a CLI      }
  117. {144}   pr_StackBase    : BPTR;         { Ptr to high memory end of process stack  }
  118. {148}   pr_Result2      : Longint;      { Value of secondary result from last call }
  119. {152}   pr_CurrentDir   : BPTR;         { Lock associated with current directory   }
  120. {156}   pr_CIS          : BPTR;         { Current CLI Input Stream                  }
  121. {160}   pr_COS          : BPTR;         { Current CLI Output Stream                 }
  122. {164}   pr_ConsoleTask  : Pointer;      { Console handler process for current window}
  123. {168}   pr_FileSystemTask : Pointer;    { File handler process for current drive   }
  124. {172}   pr_CLI          : BPTR;         { pointer to ConsoleLineInterpreter         }
  125.         pr_ReturnAddr   : Pointer;      { pointer to previous stack frame           }
  126.         pr_PktWait      : Pointer;      { Function to be called when awaiting msg  }
  127.         pr_WindowPtr    : Pointer;      { Window for error printing }
  128.         { following definitions are new with 2.0 }
  129.         pr_HomeDir      : BPTR;         { Home directory of executing program      }
  130.         pr_Flags        : Longint;      { flags telling dos about process          }
  131.         pr_ExitCode     : Pointer;      { code to call on exit of program OR NULL  }
  132.         pr_ExitData     : Longint;      { Passed as an argument to pr_ExitCode.    }
  133.         pr_Arguments    : PChar;        { Arguments passed to the process at start }
  134.         pr_LocalVars    : TMinList;      { Local environment variables             }
  135.         pr_ShellPrivate : Longint;      { for the use of the current shell         }
  136.         pr_CES          : BPTR;         { Error stream - IF NULL, use pr_COS       }
  137.     end;
  138.     PProcess = ^TProcess;
  139.  
  140.   { AmigaOS does not automatically close opened files on exit back to  }
  141.   { the operating system, therefore as a precuation we close all files }
  142.   { manually on exit.                                                  }
  143.   PFileList = ^TFileList;
  144.   TFileList = record { no packed, must be correctly aligned }
  145.    Handle: longint;      { Handle to file    }
  146.    next: pfilelist;      { Next file in list }
  147.    closed: boolean;      { TRUE=file already closed }
  148.   end;
  149.  
  150.  
  151.  
  152.  
  153.     Const
  154.      CTRL_C               = 20;      { Error code on CTRL-C press }
  155.      SIGBREAKF_CTRL_C     = $1000;   { CTRL-C signal flags }
  156.  
  157.     _LVOFindTask          = -294;
  158.     _LVOWaitPort          = -384;
  159.     _LVOGetMsg            = -372;
  160.     _LVOOpenLibrary       = -552;
  161.     _LVOCloseLibrary      = -414;
  162.     _LVOClose             = -36;
  163.     _LVOOpen              = -30;
  164.     _LVOIoErr             = -132;
  165.     _LVOSeek              = -66;
  166.     _LVODeleteFile        = -72;
  167.     _LVORename            = -78;
  168.     _LVOWrite             = -48;
  169.     _LVORead              = -42;
  170.     _LVOCreateDir         = -120;
  171.     _LVOSetCurrentDirName = -558;
  172.     _LVOGetCurrentDirName = -564;
  173.     _LVOInput             = -54;
  174.     _LVOOutput            = -60;
  175.     _LVOUnLock            = -90;
  176.     _LVOLock              = -84;
  177.     _LVOCurrentDir        = -126;
  178.  
  179.     _LVONameFromLock      = -402;
  180.     _LVONameFromFH        = -408;
  181.     _LVOGetProgramName    = -576;
  182.     _LVOGetProgramDir     = -600;
  183.     _LVODupLock           =  -96;
  184.     _LVOExamine           = -102;
  185.     _LVOParentDir         = -210;
  186.     _LVOSetFileSize       = -456;
  187.     _LVOSetSignal         = -306;
  188.     _LVOAllocVec          = -684;
  189.     _LVOFreeVec           = -690;
  190.  
  191.  
  192.       { Errors from IoErr(), etc. }
  193.       ERROR_NO_FREE_STORE              = 103;
  194.       ERROR_TASK_TABLE_FULL            = 105;
  195.       ERROR_BAD_TEMPLATE               = 114;
  196.       ERROR_BAD_NUMBER                 = 115;
  197.       ERROR_REQUIRED_ARG_MISSING       = 116;
  198.       ERROR_KEY_NEEDS_ARG              = 117;
  199.       ERROR_TOO_MANY_ARGS              = 118;
  200.       ERROR_UNMATCHED_QUOTES           = 119;
  201.       ERROR_LINE_TOO_LONG              = 120;
  202.       ERROR_FILE_NOT_OBJECT            = 121;
  203.       ERROR_INVALID_RESIDENT_LIBRARY   = 122;
  204.       ERROR_NO_DEFAULT_DIR             = 201;
  205.       ERROR_OBJECT_IN_USE              = 202;
  206.       ERROR_OBJECT_EXISTS              = 203;
  207.       ERROR_DIR_NOT_FOUND              = 204;
  208.       ERROR_OBJECT_NOT_FOUND           = 205;
  209.       ERROR_BAD_STREAM_NAME            = 206;
  210.       ERROR_OBJECT_TOO_LARGE           = 207;
  211.       ERROR_ACTION_NOT_KNOWN           = 209;
  212.       ERROR_INVALID_COMPONENT_NAME     = 210;
  213.       ERROR_INVALID_LOCK               = 211;
  214.       ERROR_OBJECT_WRONG_TYPE          = 212;
  215.       ERROR_DISK_NOT_VALIDATED         = 213;
  216.       ERROR_DISK_WRITE_PROTECTED       = 214;
  217.       ERROR_RENAME_ACROSS_DEVICES      = 215;
  218.       ERROR_DIRECTORY_NOT_EMPTY        = 216;
  219.       ERROR_TOO_MANY_LEVELS            = 217;
  220.       ERROR_DEVICE_NOT_MOUNTED         = 218;
  221.       ERROR_SEEK_ERROR                 = 219;
  222.       ERROR_COMMENT_TOO_BIG            = 220;
  223.       ERROR_DISK_FULL                  = 221;
  224.       ERROR_DELETE_PROTECTED           = 222;
  225.       ERROR_WRITE_PROTECTED            = 223;
  226.       ERROR_READ_PROTECTED             = 224;
  227.       ERROR_NOT_A_DOS_DISK             = 225;
  228.       ERROR_NO_DISK                    = 226;
  229.       ERROR_NO_MORE_ENTRIES            = 232;
  230.       { added for 1.4 }
  231.       ERROR_IS_SOFT_LINK               = 233;
  232.       ERROR_OBJECT_LINKED              = 234;
  233.       ERROR_BAD_HUNK                   = 235;
  234.       ERROR_NOT_IMPLEMENTED            = 236;
  235.       ERROR_RECORD_NOT_LOCKED          = 240;
  236.       ERROR_LOCK_COLLISION             = 241;
  237.       ERROR_LOCK_TIMEOUT               = 242;
  238.       ERROR_UNLOCK_ERROR               = 243;
  239.  
  240.  
  241.  
  242.     var
  243.       Initial: boolean;           { Have successfully opened Std I/O   }
  244.       errno : word;               { AmigaOS IO Error number            }
  245.       FileList : pFileList;       { Linked list of opened files        }
  246.       old_exit: Pointer;
  247.       FromHalt : boolean;
  248.       OrigDir : Longint;   { Current lock on original startup directory }
  249.  
  250.     {$I system.inc}
  251.     {$I lowmath.inc}
  252.  
  253.  
  254.  
  255.  
  256.   { ************************ AMIGAOS STUB ROUTINES ************************* }
  257.  
  258.   procedure DateStamp(var ds : tDateStamp);
  259.   begin
  260.    asm
  261.       MOVE.L  A6,-(A7)
  262.       MOVE.L  ds,d1
  263.       { LAST THING TO SETUP SHOULD BE A6, otherwise you can }
  264.       { not accept local variable, nor any parameters! :)   }
  265.       MOVE.L  _DOSBase,A6
  266.       JSR -192(A6)
  267.       MOVE.L  (A7)+,A6
  268.   end;
  269.  end;
  270.  
  271.  
  272.  
  273.   { UNLOCK the BPTR pointed to in L }
  274.   Procedure Unlock(alock: longint);
  275.   Begin
  276.     asm
  277.      move.l  alock,d1
  278.      move.l  a6,d6           { save base pointer    }
  279.      move.l   _DosBase,a6
  280.      jsr     _LVOUnlock(a6)
  281.      move.l  d6,a6           { restore base pointer }
  282.     end;
  283.   end;
  284.  
  285.   { Change to the directory pointed to in the lock }
  286.   Function CurrentDir(alock : longint) : longint;
  287.   Begin
  288.     asm
  289.       move.l  alock,d1
  290.       move.l  a6,d6           { save base pointer    }
  291.       move.l  _DosBase,a6
  292.       jsr     _LVOCurrentDir(a6)
  293.       move.l  d6,a6           { restore base pointer }
  294.       move.l  d0,@Result
  295.     end;
  296.   end;
  297.  
  298.   { Duplicate a lock }
  299.   Function DupLock(alock: longint): Longint;
  300.    Begin
  301.      asm
  302.        move.l  alock,d1
  303.        move.l  a6,d6           { save base pointer    }
  304.        move.l  _DosBase,a6
  305.        jsr     _LVODupLock(a6)
  306.        move.l  d6,a6           { restore base pointer }
  307.        move.l  d0,@Result
  308.      end;
  309.    end;
  310.  
  311.   { Returns a lock on the directory was loaded from }
  312.   Function GetProgramLock: longint;
  313.   Begin
  314.    asm
  315.        move.l  a6,d6           { save base pointer    }
  316.        move.l  _DosBase,a6
  317.        jsr     _LVOGetProgramDir(a6)
  318.        move.l  d6,a6           { restore base pointer }
  319.        move.l  d0,@Result
  320.    end;
  321.   end;
  322.  
  323.  
  324.  
  325.   Function Examine(alock :longint; var fib: TFileInfoBlock) : Boolean;
  326.   Begin
  327.     asm
  328.        move.l  d2,-(sp)
  329.        move.l  fib,d2         { pointer to FIB        }
  330.        move.l  alock,d1
  331.        move.l  a6,d6           { save base pointer    }
  332.        move.l  _DosBase,a6
  333.        jsr     _LVOExamine(a6)
  334.        move.l  d6,a6           { restore base pointer }
  335.        tst.l   d0
  336.        bne     @success
  337.        bra     @end
  338.     @success:
  339.        move.b  #1,d0
  340.     @end:
  341.        move.b  d0,@Result
  342.        move.l  (sp)+,d2
  343.     end;
  344.   end;
  345.  
  346.   { Returns the parent directory of a lock }
  347.   Function ParentDir(alock : longint): longint;
  348.    Begin
  349.      asm
  350.        move.l  alock,d1
  351.        move.l  a6,d6           { save base pointer    }
  352.        move.l  _DosBase,a6
  353.        jsr     _LVOParentDir(a6)
  354.        move.l  d6,a6           { restore base pointer }
  355.        move.l  d0,@Result
  356.      end;
  357.    end;
  358.  
  359.  
  360.    Function FindTask(p : PChar): PProcess;
  361.    Begin
  362.     asm
  363.          move.l  a6,d6              { Save base pointer    }
  364.          move.l  p,d0
  365.          move.l  d0,a1
  366.          move.l  _ExecBase,a6
  367.          jsr     _LVOFindTask(a6)
  368.          move.l  d6,a6              { Restore base pointer }
  369.          move.l  d0,@Result
  370.     end;
  371.    end;
  372.  
  373.  
  374. {$S-}
  375.     Procedure stack_check; assembler;
  376.     { Check for local variable allocation }
  377.     { On Entry -> d0 : size of local stack we are trying to allocate }
  378.      asm
  379.       XDEF STACKCHECK
  380.         move.l  sp,d1            { get value of stack pointer            }
  381.  
  382.         { We must add some security, because Writing the RunError strings }
  383.         { requires a LOT of stack space (at least 1030 bytes!)            }
  384.         add.l   #2048,d0
  385.         sub.l   d0,d1            {  sp - stack_size                      }
  386.  
  387.         move.l  _ExecBase,a0
  388.         move.l  276(A0),A0       { ExecBase.thisTask }
  389.         { if allocated stack_pointer - splower <= 0 then stack_ovf       }
  390.         cmp.l   58(A0),D1        { Task.SpLower      }
  391.         bgt     @Ok
  392.         move.l  #202,d0
  393.         jsr     HALT_ERROR       { stack overflow    }
  394.     @Ok:
  395.    end;
  396.  
  397.  
  398.    { This routine from EXEC determines if the Ctrl-C key has }
  399.    { been used since the last call to I/O routines.          }
  400.    { Use to halt the program.                                }
  401.    { Returns the state of the old signals.                   }
  402.    Function SetSignal(newSignal: longint; SignalMask: longint): longint;
  403.    Begin
  404.      asm
  405.        move.l  newSignal,d0
  406.        move.l  SignalMask,d1
  407.        move.l  a6,d6          { save Base pointer into scratch register }
  408.        move.l  _ExecBase,a6
  409.        jsr     _LVOSetSignal(a6)
  410.        move.l  d6,a6
  411.        move.l  d0,@Result
  412.      end;
  413.    end;
  414.  
  415.  
  416.    Function AllocVec(bytesize: longint; attributes: longint):longint;
  417.    Begin
  418.      asm
  419.        move.l  bytesize,d0
  420.        move.l  attributes,d1
  421.        move.l  a6,d6          { save Base pointer into scratch register }
  422.        move.l  _ExecBase,a6
  423.        jsr     _LVOAllocVec(a6)
  424.        move.l  d6,a6
  425.        move.l  d0,@Result
  426.      end;
  427.    end;
  428.  
  429.  
  430.    Procedure FreeVec(p: longint);
  431.    Begin
  432.      asm
  433.        move.l  p,a1
  434.        move.l  a6,d6          { save Base pointer into scratch register }
  435.        move.l  _ExecBase,a6
  436.        jsr     _LVOFreeVec(a6)
  437.        move.l  d6,a6
  438.      end;
  439.    end;
  440.  
  441.  
  442.    { Converts an AMIGAOS error code to a TP compatible error code }
  443.    Procedure Error2InOut;
  444.    Begin
  445.      case errno of
  446.        ERROR_BAD_NUMBER,
  447.        ERROR_ACTION_NOT_KNOWN,
  448.        ERROR_NOT_IMPLEMENTED : InOutRes := 1;
  449.  
  450.        ERROR_OBJECT_NOT_FOUND : InOutRes := 2;
  451.        ERROR_DIR_NOT_FOUND :  InOutRes := 3;
  452.  
  453.        ERROR_DISK_WRITE_PROTECTED : InOutRes := 150;
  454.  
  455.        ERROR_OBJECT_WRONG_TYPE : InOutRes := 151;
  456.  
  457.        ERROR_OBJECT_EXISTS,
  458.        ERROR_DELETE_PROTECTED,
  459.        ERROR_WRITE_PROTECTED,
  460.        ERROR_READ_PROTECTED,
  461.        ERROR_OBJECT_IN_USE,
  462.        ERROR_DIRECTORY_NOT_EMPTY : InOutRes := 5;
  463.  
  464.        ERROR_NO_MORE_ENTRIES : InOutRes := 18;
  465.  
  466.        ERROR_RENAME_ACROSS_DEVICES : InOutRes := 17;
  467.  
  468.        ERROR_DISK_FULL : InOutRes := 101;
  469.  
  470.        ERROR_INVALID_RESIDENT_LIBRARY : InoutRes := 153;
  471.        ERROR_BAD_HUNK : InOutRes := 153;
  472.  
  473.        ERROR_NOT_A_DOS_DISK : InOutRes := 157;
  474.  
  475.        ERROR_NO_DISK,
  476.        ERROR_DISK_NOT_VALIDATED,
  477.        ERROR_DEVICE_NOT_MOUNTED : InOutRes := 152;
  478.  
  479.        ERROR_SEEK_ERROR : InOutRes := 156;
  480.  
  481.        ERROR_LOCK_COLLISION,
  482.        ERROR_LOCK_TIMEOUT,
  483.        ERROR_UNLOCK_ERROR,
  484.        ERROR_INVALID_LOCK,
  485.        ERROR_INVALID_COMPONENT_NAME,
  486.        ERROR_BAD_STREAM_NAME,
  487.        ERROR_FILE_NOT_OBJECT : InOutRes := 6;
  488.      else
  489.        InOutres := errno;
  490.      end;
  491.      errno:=0;
  492.    end;
  493.  
  494.  
  495.     procedure CloseLibrary(lib : pointer);
  496.     {  Close the library pointed to in lib }
  497.     Begin
  498.       asm
  499.          MOVE.L  A6,-(A7)
  500.          MOVE.L  lib,a1
  501.          MOVE.L  _ExecBase,A6
  502.          JSR     _LVOCloseLibrary(A6)
  503.          MOVE.L  (A7)+,A6
  504.       end;
  505.     end;
  506.  
  507.  
  508.    Function KickVersion: word; assembler;
  509.    asm
  510.      move.l  _ExecBase, a0       { Get Exec Base                           }
  511.      move.w  20(a0), d0          { Return version - version at this offset }
  512.    end;
  513.  
  514.  
  515.   { ************************ AMIGAOS SUPP ROUTINES ************************* }
  516.  
  517. (*  Procedure CloseList(p: pFileList);*)
  518.   (***********************************************************************)
  519.   (* PROCEDURE CloseList                                                 *)
  520.   (*  Description: This routine each time the program is about to        *)
  521.   (*  terminate, it closes all opened file handles, as this is not       *)
  522.   (*  handled by the operating system.                                   *)
  523.   (*   p -> Start of linked list of opened files                         *)
  524.   (***********************************************************************)
  525. (*  var
  526.    hp: pFileList;
  527.    hp1: pFileList;
  528.    h: longint;
  529.   Begin
  530.    hp:=p;
  531.    while Assigned(hp) do
  532.     Begin
  533.       if NOT hp^.closed then
  534.        Begin
  535.         h:=hp^.handle;
  536.         if (h <> StdInputHandle) and (h <> StdOutputHandle) and (h <> StdErrorHandle) then
  537.         Begin
  538.           { directly close file here, it is faster then doing }
  539.           { it do_close.                                      }
  540.           asm
  541.             move.l  h,d1
  542.             move.l  a6,d6              { save a6 }
  543.             move.l  _DOSBase,a6
  544.             jsr     _LVOClose(a6)
  545.             move.l  d6,a6              { restore a6 }
  546.           end;
  547.         end;
  548.        end;
  549.       hp1:=hp;
  550.       hp:=hp^.next;
  551.       dispose(hp1);
  552.     end;
  553.   end;*)
  554.  
  555.  
  556. (* Procedure AddToList(var p: pFileList; h: longint);*)
  557.   (***********************************************************************)
  558.   (* PROCEDURE AddToList                                                 *)
  559.   (*  Description: Adds a node to the linked list of files.              *)
  560.   (*                                                                     *)
  561.   (*   p -> Start of File list linked list, if not allocated allocates   *)
  562.   (*        it for you.                                                  *)
  563.   (*   h -> handle of file to add                                        *)
  564.   (***********************************************************************)
  565. (*  var
  566.    hp: pFileList;
  567.    hp1: pFileList;
  568.   Begin
  569.     if p = nil then
  570.      Begin
  571.        new(p);
  572.        p^.handle:=h;
  573.        p^.closed := FALSE;
  574.        p^.next := nil;
  575.        exit;
  576.      end;
  577.      hp:=p;
  578.     { Find last list in entry }
  579.     while assigned(hp) do
  580.      Begin
  581.         if hp^.next = nil then break;
  582.         hp:=hp^.next;
  583.      end;
  584.     { Found last list in entry then add it to the list }
  585.     new(hp1);
  586.     hp^.next:=hp1;
  587.     hp1^.next:=nil;
  588.     hp1^.handle:=h;
  589.     hp1^.closed:=FALSE;
  590.   end;
  591.  
  592.  
  593.   Procedure SetClosedList(var p: pFileList; h: longint);
  594.   { Set the file flag to closed if the file is being closed }
  595.   var
  596.    hp: pFileList;
  597.   Begin
  598.     hp:=p;
  599.     while assigned(hp) do
  600.      Begin
  601.         if hp^.handle = h then
  602.          Begin
  603.            hp^.closed:=TRUE;
  604.            break;
  605.          end;
  606.         hp:=hp^.next;
  607.      end;
  608.   end;*)
  609.  
  610.  
  611.     Procedure ExitCall;
  612.     var
  613.      i: byte;
  614.     Begin
  615.         { We must remove the CTRL-C FALG here because halt }
  616.         { may call I/O routines, which in turn might call  }
  617.         { halt, so a recursive stack crash                 }
  618.         IF (SetSignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 THEN
  619.            SetSignal(0,SIGBREAKF_CTRL_C);
  620.          { Close remaining opened files }
  621. {         CloseList(FileList); }
  622.         if (OrigDir <> 0) then
  623.          Begin
  624.             Unlock(CurrentDir(OrigDir));
  625.             OrigDir := 0;
  626.          end;
  627.          { Is this a normal exit - YES, close libs }
  628.          IF NOT FromHalt then
  629.            Begin
  630.              { close the libraries }
  631.              If _UtilityBase <> nil then
  632.                  CloseLibrary(_UtilityBase);
  633.              If _DosBase <> nil then
  634.                  CloseLibrary(_DosBase);
  635.              If _IntuitionBase <> nil then
  636.                  CloseLibrary(_IntuitionBase);
  637.              _UtilityBase := nil;
  638.              _DosBase := nil;
  639.              _IntuitionBase := nil;
  640.            end;
  641.          { Dispose of extraneous allocated pointers }
  642.          for I:=1 to 8 do
  643.            Begin
  644.              if pointerlist[i] <> 0 then FreeVec(pointerlist[i]);
  645.            end;
  646.          exitproc:=old_exit;
  647.     end;
  648.  
  649.  
  650.     procedure halt(errnum : byte);
  651.       begin
  652.         { Indicate to the SYSTEM EXIT procedure that we are calling it }
  653.         { from halt, and that its library will be closed HERE and not  }
  654.         { in the exit procedure.                                       }
  655.         FromHalt:=TRUE;
  656.         { We must remove the CTRL-C FALG here because halt }
  657.         { may call I/O routines, which in turn might call  }
  658.         { halt, so a recursive stack crash                 }
  659.         IF (SetSignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 THEN
  660.            SetSignal(0,SIGBREAKF_CTRL_C);
  661.         { WE can only FLUSH the stdio   }
  662.         { if the handles have correctly }
  663.         { been set.                     }
  664.         { No exit procedures exist      }
  665.         { if in initial state           }
  666.         If NOT Initial then
  667.         Begin
  668.           do_exit;
  669.           flush(stderr);
  670.         end;
  671.         { close the libraries }
  672.         If _UtilityBase <> nil then
  673.            CloseLibrary(_UtilityBase);
  674.         If _DosBase <> nil then
  675.            CloseLibrary(_DosBase);
  676.         If _IntuitionBase <> nil then
  677.            CloseLibrary(_IntuitionBase);
  678.         _UtilityBase := nil;
  679.         _DosBase := nil;
  680.         _IntuitionBase := nil;
  681.          asm
  682.             clr.l   d0
  683.             move.b  errnum,d0
  684.             move.l  STKPTR,sp
  685.             rts
  686.          end;
  687.       end;
  688.  
  689.  
  690.  
  691.   { ************************ PARAMCOUNT/PARAMSTR *************************** }
  692.  
  693.       function paramcount : longint;
  694.       Begin
  695.         paramcount := argc;
  696.       end;
  697.  
  698.  
  699.       function args : pointer; assembler;
  700.       asm
  701.          move.l __ARGS,d0
  702.       end;
  703.  
  704.    Function GetParamCount(const p: pchar): longint;
  705.    var
  706.     i: word;
  707.     count: word;
  708.    Begin
  709.     i:=0;
  710.     count:=0;
  711.     while p[count] <> #0 do
  712.      Begin
  713.        if (p[count] <> ' ') and (p[count] <> #9) and (p[count] <> #0) then
  714.        Begin
  715.           i:=i+1;
  716.           while (p[count] <> ' ') and (p[count] <> #9) and (p[count] <> #0) do
  717.            count:=count+1;
  718.        end;
  719.        if p[count] = #0 then break;
  720.        count:=count+1;
  721.      end;
  722.      GetParamCount:=longint(i);
  723.    end;
  724.  
  725.  
  726.    Function GetParam(index: word; const p : pchar): string;
  727.    { On Entry: index = string index to correct parameter  }
  728.    { On exit:  = correct character index into pchar array }
  729.    { Returns correct index to command line argument }
  730.    var
  731.     count: word;
  732.     localindex: word;
  733.     l: byte;
  734.     temp: string;
  735.    Begin
  736.      temp:='';
  737.      count := 0;
  738.      { first index is one }
  739.      localindex := 1;
  740.      l:=0;
  741.      While p[count] <> #0 do
  742.        Begin
  743.          if (p[count] <> ' ') and (p[count] <> #9) then
  744.            Begin
  745.              if localindex = index then
  746.               Begin
  747.                while (p[count] <> #0) and (p[count] <> ' ') and (p[count] <> #9) and (l < 256) do
  748.                 Begin
  749.                   temp:=temp+p[count];
  750.                   l:=l+1;
  751.                   count:=count+1;
  752.                 end;
  753.                 temp[0]:=char(l);
  754.                 GetParam:=temp;
  755.                 exit;
  756.               end;
  757.              { Point to next argument in list }
  758.              while (p[count] <> #0) and (p[count] <> ' ') and (p[count] <> #9) do
  759.                Begin
  760.                  count:=count+1;
  761.                end;
  762.              localindex:=localindex+1;
  763.            end;
  764.          if p[count] = #0 then break;
  765.          count:=count+1;
  766.        end;
  767.      GetParam:=temp;
  768.    end;
  769.  
  770.  
  771.     Function GetProgramDir : String;
  772.     var
  773.      s1: string;
  774.      alock: longint;
  775.      counter : byte;
  776.     Begin
  777.      FillChar(@s1,255,#0);
  778.      { GetLock of program directory }
  779.      asm
  780.             move.l  a6,d6              { save a6 }
  781.             move.l  _DOSBase,a6
  782.             jsr     _LVOGetProgramDir(a6)
  783.             move.l  d6,a6              { restore a6 }
  784.             move.l  d0,alock           { save the lock }
  785.      end;
  786.      if alock <> 0 then
  787.       Begin
  788.         { Get the name from the lock! }
  789.         asm
  790.             movem.l d2/d3,-(sp)        { save used registers             }
  791.             move.l  alock,d1
  792.             lea     s1,a0              { Get pointer to string!          }
  793.             move.l  a0,d2
  794.             add.l   #1,d2              { let  us point past the length byte! }
  795.             move.l  #255,d3
  796.             move.l  a6,d6              { save a6 }
  797.             move.l  _DOSBase,a6
  798.             jsr     _LVONameFromLock(a6)
  799.             move.l  d6,a6              { restore a6 }
  800.             movem.l (sp)+,d2/d3
  801.         end;
  802.         { no check out the length of the string }
  803.         counter := 1;
  804.         while s1[counter] <> #0 do
  805.            Inc(counter);
  806.         s1[0] := char(counter-1);
  807.         GetProgramDir := s1;
  808.       end
  809.      else
  810.       GetProgramDir := '';
  811.     end;
  812.  
  813.  
  814.     Function GetProgramName : string;
  815.     { Returns ONLY the program name }
  816.     { There seems to be a bug in v39 since if the program is not }
  817.     { called from its home directory the program name will also  }
  818.     { contain the path!                                          }
  819.     var
  820.      s1: string;
  821.      counter : byte;
  822.     Begin
  823.       FillChar(@s1,255,#0);
  824.       asm
  825.             move.l  d2,-(sp)           { Save used register      }
  826.             lea     s1,a0              { Get pointer to string!  }
  827.             move.l  a0,d1
  828.             add.l   #1,d1              { point to correct offset }
  829.             move.l  #255,d2
  830.             move.l  a6,d6              { save a6 }
  831.             move.l  _DOSBase,a6
  832.             jsr     _LVOGetProgramName(a6)
  833.             move.l  d6,a6              { restore a6 }
  834.             move.l  (sp)+,d2           { restore saved register }
  835.       end;
  836.         { no check out and assign the length of the string }
  837.         counter := 1;
  838.         while s1[counter] <> #0 do
  839.            Inc(counter);
  840.         s1[0] := char(counter-1);
  841.         { now remove any component path which should not be there }
  842.         for counter:=length(s1) downto 1 do
  843.           if (s1[counter] = '/') or (s1[counter] = ':') then break;
  844.         { readjust counterv to point to character }
  845.         if counter <> 1 then
  846.           Inc(counter);
  847.         GetProgramName:=copy(s1,counter,length(s1));
  848.     end;
  849.  
  850.  
  851.     function paramstr(l : longint) : string;
  852.       var
  853.        p : pchar;
  854.        s1 : string;
  855.       begin
  856.          {   -> Call AmigaOS GetProgramName                             }
  857.          if l = 0 then
  858.          Begin
  859.            s1 := GetProgramDir;
  860.            { If this is a root, then simply don't add '/' }
  861.            if s1[length(s1)] = ':' then
  862.               paramstr:=s1+GetProgramName
  863.            else
  864.               { add backslash directory }
  865.               paramstr:=s1+'/'+GetProgramName
  866.          end
  867.          else
  868.          if (l>0) and (l<=paramcount) then
  869.            begin
  870.              p:=args;
  871.              paramstr:=GetParam(word(l),p);
  872.            end
  873.          else paramstr:='';
  874.       end;
  875.  
  876.   { ************************************************************************ }
  877.  
  878.     procedure randomize;
  879.  
  880.       var
  881.          hl : longint;
  882.          time : TDateStamp;
  883.       begin
  884.          DateStamp(time);
  885.          randseed:=time.ds_tick;
  886.       end;
  887.  
  888.   { This routine is used to grow the heap.  }
  889.   { But here we do a trick, we say that the }
  890.   { heap cannot be regrown!                 }
  891.   function sbrk( size: longint): longint;
  892.   var
  893.   { on exit -1 = if fails.               }
  894.    p: longint;
  895.    i: byte;
  896.   Begin
  897.     p:=0;
  898.     { Is the pointer list full }
  899.     if pointerlist[8] <> 0 then
  900.     begin
  901.      { yes, then don't allocate and simply exit }
  902.      sbrk:=-1;
  903.      exit;
  904.     end;
  905.     { Allocate best available memory }
  906.     p:=AllocVec(size,0);
  907.     if p = 0 then
  908.      sbrk:=-1
  909.     else
  910.     Begin
  911.        i:=1;
  912.        { add it to the list of allocated pointers }
  913.        { first find the last pointer in the list  }
  914.        while (i < 8) and (pointerlist[i] <> 0) do
  915.          i:=i+1;
  916.        pointerlist[i]:=p;
  917.        sbrk:=p;
  918.     end;
  919.   end;
  920.  
  921.  
  922.  
  923. {$I heap.inc}
  924.  
  925.  
  926. {****************************************************************************
  927.                           Low Level File Routines
  928.  ****************************************************************************}
  929.  
  930. procedure do_close(h : longint);
  931. { We cannot check for CTRL-C because this routine will be called }
  932. { on HALT to close all remaining opened files. Therefore no      }
  933. { CTRL-C checking otherwise a recursive call might result!       }
  934. {$ifdef debug}
  935. var
  936.   buffer: array[0..255] of char;
  937. {$endif}
  938. begin
  939.   { check if the file handle is in the list }
  940.   { if so the put its field to closed       }
  941. {  SetClosedList(FileList,h);}
  942. {$ifdef debug}
  943.   asm
  944.      move.l  h,d1
  945.      move.l  a6,d6
  946.      move.l  d2,-(sp)
  947.      move.l  d3,-(sp)
  948.      lea     buffer,a0
  949.      move.l  a0,d2
  950.      move.l  #255,d3
  951.      move.l  _DosBase,a6
  952.      jsr     _LVONameFromFH(a6)
  953.      move.l  d6,a6
  954.      move.l  (sp)+,d3
  955.      move.l  (sp)+,d2
  956.   end;
  957.   WriteLn(Buffer);
  958. {$endif debug}
  959.   asm
  960.      move.l  h,d1
  961.      move.l  a6,d6              { save a6 }
  962.      move.l  _DOSBase,a6
  963.      jsr     _LVOClose(a6)
  964.      move.l  d6,a6              { restore a6 }
  965.   end;
  966. end;
  967.  
  968.  
  969. function do_isdevice(handle:longint):boolean;
  970. begin
  971.   if (handle=stdoutputhandle) or (handle=stdinputhandle) or
  972.   (handle=stderrorhandle) then
  973.     do_isdevice:=TRUE
  974.   else
  975.     do_isdevice:=FALSE;
  976. end;
  977.  
  978.  
  979.  
  980. procedure do_erase(p : pchar);
  981. begin
  982.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  983.    Begin
  984.      SetSignal(0,SIGBREAKF_CTRL_C);
  985.      Halt(CTRL_C);
  986.    end;
  987.   asm
  988.            move.l  a6,d6               { save a6 }
  989.  
  990.            move.l  p,d1
  991.            move.l  _DOSBase,a6
  992.            jsr     _LVODeleteFile(a6)
  993.            tst.l   d0                  { zero = failure }
  994.            bne     @noerror
  995.  
  996.            jsr     _LVOIoErr(a6)
  997.            move.w  d0,errno
  998.  
  999.          @noerror:
  1000.            move.l  d6,a6               { restore a6 }
  1001.   end;
  1002.   if errno <> 0 then
  1003.      Error2InOut;
  1004. end;
  1005.  
  1006.  
  1007. procedure do_rename(p1,p2 : pchar);
  1008. begin
  1009.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  1010.    Begin
  1011.      SetSignal(0,SIGBREAKF_CTRL_C);
  1012.      Halt(CTRL_C);
  1013.    end;
  1014.   asm
  1015.            move.l  a6,d6                  { save a6 }
  1016.            move.l  d2,-(sp)               { save d2 }
  1017.  
  1018.            move.l  p1,d1
  1019.            move.l  p2,d2
  1020.            move.l  _DOSBase,a6
  1021.            jsr     _LVORename(a6)
  1022.            move.l  (sp)+,d2               { restore d2 }
  1023.            tst.l   d0
  1024.            bne     @dosreend              { if zero = error }
  1025.            jsr     _LVOIoErr(a6)
  1026.            move.w  d0,errno
  1027.          @dosreend:
  1028.            move.l  d6,a6                  { restore a6 }
  1029.   end;
  1030.   if errno <> 0 then
  1031.     Error2InOut;
  1032. end;
  1033.  
  1034.  
  1035. function do_write(h,addr,len : longint) : longint;
  1036. begin
  1037.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  1038.    Begin
  1039.      SetSignal(0,SIGBREAKF_CTRL_C);
  1040.      Halt(CTRL_C);
  1041.    end;
  1042.   if len <= 0 then
  1043.    Begin
  1044.     do_write:=0;
  1045.     exit;
  1046.    end;
  1047.   asm
  1048.             move.l  a6,d6
  1049.  
  1050.             movem.l d2/d3,-(sp)
  1051.             move.l  h,d1             { we must of course set up the }
  1052.             move.l  addr,d2          { parameters BEFORE getting    }
  1053.             move.l  len,d3           { _DOSBase                     }
  1054.             move.l  _DOSBase,a6
  1055.             jsr     _LVOWrite(a6)
  1056.             movem.l (sp)+,d2/d3
  1057.  
  1058.             cmp.l   #-1,d0
  1059.             bne     @doswrend              { if -1 = error }
  1060.             jsr     _LVOIoErr(a6)
  1061.             move.w  d0,errno
  1062.             bra     @doswrend2
  1063.           @doswrend:
  1064.             { we must restore the base pointer before setting the result }
  1065.             move.l  d6,a6
  1066.             move.l  d0,@RESULT
  1067.             bra     @end
  1068.           @doswrend2:
  1069.             move.l  d6,a6
  1070.           @end:
  1071.   end;
  1072.   If errno <> 0 then
  1073.     Error2InOut;
  1074. end;
  1075.  
  1076.  
  1077. function do_read(h,addr,len : longint) : longint;
  1078. begin
  1079.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  1080.    Begin
  1081.      SetSignal(0,SIGBREAKF_CTRL_C);
  1082.      Halt(CTRL_C);
  1083.    end;
  1084.   if len <= 0 then
  1085.   Begin
  1086.      do_read:=0;
  1087.      exit;
  1088.   end;
  1089.   asm
  1090.             move.l  a6,d6
  1091.  
  1092.             movem.l d2/d3,-(sp)
  1093.             move.l  h,d1         { we must set up aparamters BEFORE }
  1094.             move.l  addr,d2      { setting up a6 for the OS call    }
  1095.             move.l  len,d3
  1096.             move.l  _DOSBase,a6
  1097.             jsr     _LVORead(a6)
  1098.             movem.l (sp)+,d2/d3
  1099.  
  1100.             cmp.l   #-1,d0
  1101.             bne     @doswrend              { if -1 = error }
  1102.             jsr     _LVOIoErr(a6)
  1103.             move.w  d0,errno
  1104.             bra     @doswrend2
  1105.           @doswrend:
  1106.             { to store a result for the function  }
  1107.             { we must of course first get back the}
  1108.             { base pointer!                       }
  1109.             move.l  d6,a6
  1110.             move.l  d0,@RESULT
  1111.             bra     @end
  1112.           @doswrend2:
  1113.             move.l  d6,a6
  1114.           @end:
  1115.   end;
  1116.   If errno <> 0 then
  1117.     Error2InOut;
  1118. end;
  1119.  
  1120.  
  1121. function do_filepos(handle : longint) : longint;
  1122. begin
  1123.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  1124.    Begin
  1125.      { Clear CTRL-C signal }
  1126.      SetSignal(0,SIGBREAKF_CTRL_C);
  1127.      Halt(CTRL_C);
  1128.    end;
  1129.   asm
  1130.              move.l  a6,d6
  1131.  
  1132.              move.l  handle,d1
  1133.              move.l  d2,-(sp)
  1134.              move.l  d3,-(sp)              { save registers              }
  1135.  
  1136.              clr.l   d2                    { offset 0 }
  1137.              move.l  #0,d3                 { OFFSET_CURRENT }
  1138.              move.l  _DOSBase,a6
  1139.              jsr    _LVOSeek(a6)
  1140.  
  1141.              move.l  (sp)+,d3              { restore registers }
  1142.              move.l  (sp)+,d2
  1143.              cmp.l   #-1,d0                { is there a file access error? }
  1144.              bne     @noerr
  1145.              jsr     _LVOIoErr(a6)
  1146.              move.w  d0,errno
  1147.              bra     @fposend
  1148.       @noerr:
  1149.              move.l  d6,a6                 { restore a6 }
  1150.              move.l  d0,@Result
  1151.              bra     @end
  1152.       @fposend:
  1153.              move.l  d6,a6                 { restore a6 }
  1154.       @end:
  1155.   end;
  1156.   If errno <> 0 then
  1157.     Error2InOut;
  1158. end;
  1159.  
  1160.  
  1161. procedure do_seek(handle,pos : longint);
  1162. begin
  1163.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  1164.    Begin
  1165.      { Clear CTRL-C signal }
  1166.      SetSignal(0,SIGBREAKF_CTRL_C);
  1167.      Halt(CTRL_C);
  1168.    end;
  1169.   asm
  1170.              move.l  a6,d6
  1171.  
  1172.              move.l  handle,d1
  1173.              move.l  d2,-(sp)
  1174.              move.l  d3,-(sp)              { save registers              }
  1175.  
  1176.              move.l  pos,d2
  1177.              { -1 }
  1178.              move.l  #$ffffffff,d3          { OFFSET_BEGINNING }
  1179.              move.l  _DOSBase,a6
  1180.              jsr    _LVOSeek(a6)
  1181.  
  1182.              move.l  (sp)+,d3              { restore registers }
  1183.              move.l  (sp)+,d2
  1184.              cmp.l   #-1,d0                { is there a file access error? }
  1185.              bne     @noerr
  1186.              jsr     _LVOIoErr(a6)
  1187.              move.w  d0,errno
  1188.              bra     @seekend
  1189.       @noerr:
  1190.       @seekend:
  1191.              move.l  d6,a6                 { restore a6 }
  1192.   end;
  1193.   If errno <> 0 then
  1194.     Error2InOut;
  1195. end;
  1196.  
  1197.  
  1198. function do_seekend(handle:longint):longint;
  1199. begin
  1200.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  1201.    Begin
  1202.      { Clear CTRL-C signal }
  1203.      SetSignal(0,SIGBREAKF_CTRL_C);
  1204.      Halt(CTRL_C);
  1205.    end;
  1206.   asm
  1207.              { seek from end of file }
  1208.              move.l  a6,d6
  1209.  
  1210.              move.l  handle,d1
  1211.              move.l  d2,-(sp)
  1212.              move.l  d3,-(sp)              { save registers              }
  1213.  
  1214.              clr.l   d2
  1215.              move.l  #1,d3                 { OFFSET_END }
  1216.              move.l  _DOSBase,a6
  1217.              jsr    _LVOSeek(a6)
  1218.  
  1219.              move.l  (sp)+,d3              { restore registers }
  1220.              move.l  (sp)+,d2
  1221.              cmp.l   #-1,d0                { is there a file access error? }
  1222.              bne     @noerr
  1223.              jsr     _LVOIoErr(a6)
  1224.              move.w  d0,errno
  1225.              bra     @seekend
  1226.       @noerr:
  1227.              move.l  d6,a6                 { restore a6 }
  1228.              move.l  d0,@Result
  1229.              bra     @end
  1230.       @seekend:
  1231.              move.l  d6,a6                 { restore a6 }
  1232.       @end:
  1233.   end;
  1234.   If Errno <> 0 then
  1235.     Error2InOut;
  1236. end;
  1237.  
  1238.  
  1239. function do_filesize(handle : longint) : longint;
  1240. var
  1241.   aktfilepos : longint;
  1242. begin
  1243.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  1244.     Begin
  1245.      { Clear CTRL-C signal }
  1246.      SetSignal(0,SIGBREAKF_CTRL_C);
  1247.      Halt(CTRL_C);
  1248.     end;
  1249.    aktfilepos:=do_filepos(handle);
  1250.    { We have to do this two times, because seek returns the }
  1251.    { OLD position                                           }
  1252.    do_filesize:=do_seekend(handle);
  1253.    do_filesize:=do_seekend(handle);
  1254.    do_seek(handle,aktfilepos);
  1255. end;
  1256.  
  1257.  
  1258. procedure do_truncate (handle,pos:longint);
  1259. begin
  1260.       { Point to the end of the file }
  1261.       { with the new size            }
  1262.       asm
  1263.       @noerr_one:                          { Seek a second time            }
  1264.              move.l  a6,d6                 { Save base pointer             }
  1265.  
  1266.              move.l  handle,d1
  1267.              move.l  d2,-(sp)
  1268.              move.l  d3,-(sp)              { save registers                }
  1269.  
  1270.              move.l  pos,d2
  1271.              move.l  #-1,d3                { Setup correct move type     }
  1272.              move.l  _DOSBase,a6           { from beginning of file      }
  1273.              jsr    _LVOSetFileSize(a6)
  1274.  
  1275.              move.l  (sp)+,d3              { restore registers }
  1276.              move.l  (sp)+,d2
  1277.              cmp.l   #-1,d0                { is there a file access error? }
  1278.              bne     @noerr
  1279.              jsr     _LVOIoErr(a6)
  1280.              move.w  d0,errno              { Global variable, so no need    }
  1281.       @noerr:                              { to restore base pointer now    }
  1282.              move.l  d6,a6                 { Restore base pointer           }
  1283.       end;
  1284.   If Errno <> 0 then
  1285.     Error2InOut;
  1286. end;
  1287.  
  1288.  
  1289. procedure do_open(var f;p:pchar;flags:longint);
  1290. {
  1291.   filerec and textrec have both handle and mode as the first items so
  1292.   they could use the same routine for opening/creating.
  1293.   when (flags and $10)   the file will be append
  1294.   when (flags and $100)  the file will be truncate/rewritten
  1295.   when (flags and $1000) there is no check for close (needed for textfiles)
  1296. }
  1297. var
  1298.   i,j : longint;
  1299.   oflags: longint;
  1300.   path : string;
  1301.   buffer : array[0..255] of char;
  1302.   index : integer;
  1303.   s : string;
  1304. begin
  1305.  path:=strpas(p);
  1306.  for index:=1 to length(path) do
  1307.    if path[index]='\' then path[index]:='/';
  1308.  { remove any dot characters and replace by their current }
  1309.  { directory equivalent.                                  }
  1310.  if pos('../',path) = 1 then
  1311.  { look for parent directory }
  1312.     Begin
  1313.        delete(path,1,3);
  1314.        getdir(0,s);
  1315.        j:=length(s);
  1316.        while (s[j] <> '/') AND (s[j] <> ':') AND (j > 0 ) do
  1317.          dec(j);
  1318.        if j > 0 then
  1319.          s:=copy(s,1,j);
  1320.        path:=s+path;
  1321.     end
  1322.  else
  1323.  if pos('./',path) = 1 then
  1324.  { look for current directory }
  1325.     Begin
  1326.        delete(path,1,2);
  1327.        getdir(0,s);
  1328.        if (s[length(s)] <> '/') and (s[length(s)] <> ':') then
  1329.           s:=s+'/';
  1330.        path:=s+path;
  1331.     end;
  1332.   move(path[1],buffer,length(path));
  1333.   buffer[length(path)]:=#0;
  1334.  { close first if opened }
  1335.   if ((flags and $1000)=0) then
  1336.    begin
  1337.      case filerec(f).mode of
  1338.       fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
  1339.       fmclosed : ;
  1340.      else
  1341.       begin
  1342.         inoutres:=102; {not assigned}
  1343.         exit;
  1344.       end;
  1345.      end;
  1346.    end;
  1347. { reset file handle }
  1348.   filerec(f).handle:=UnusedHandle;
  1349. { convert filemode to filerec modes }
  1350.   { READ/WRITE on existing file }
  1351.   { RESET/APPEND                }
  1352.   oflags := 1005;
  1353.   case (flags and 3) of
  1354.    0 : begin
  1355.          filerec(f).mode:=fminput;
  1356.        end;
  1357.    1 : filerec(f).mode:=fmoutput;
  1358.    2 : filerec(f).mode:=fminout;
  1359.   end;
  1360.   { READ/WRITE mode, create file in all cases }
  1361.   { REWRITE                                   }
  1362.   if (flags and $100)<>0 then
  1363.    begin
  1364.      filerec(f).mode:=fmoutput;
  1365.      oflags := 1006;
  1366.    end
  1367.   else
  1368.   { READ/WRITE mode on existing file }
  1369.   { APPEND                           }
  1370.    if (flags and $10)<>0 then
  1371.     begin
  1372.       filerec(f).mode:=fmoutput;
  1373.       oflags := 1005;
  1374.     end;
  1375. { empty name is special }
  1376.   if p[0]=#0 then
  1377.    begin
  1378.      case filerec(f).mode of
  1379.        fminput : filerec(f).handle:=StdInputHandle;
  1380.       fmappend,
  1381.       fmoutput : begin
  1382.                    filerec(f).handle:=StdOutputHandle;
  1383.                    filerec(f).mode:=fmoutput; {fool fmappend}
  1384.                  end;
  1385.      end;
  1386.      exit;
  1387.    end;
  1388.          asm
  1389.              move.l  a6,d6                  { save a6 }
  1390.              move.l  d2,-(sp)
  1391.              lea     buffer,a0
  1392.              move.l  a0,d1
  1393.              move.l  oflags,d2               { MODE_READWRITE }
  1394.              move.l  _DOSBase,a6
  1395.              jsr     _LVOOpen(a6)
  1396.              tst.l   d0
  1397.              bne     @noopenerror           { on zero an error occured }
  1398.              jsr     _LVOIoErr(a6)
  1399.              move.w  d0,errno
  1400.              bra     @openend
  1401.           @noopenerror:
  1402.              move.l  (sp)+,d2
  1403.              move.l  d6,a6                 { restore a6 }
  1404.              move.l  d0,i                  { we need the base pointer to access this variable }
  1405.              bra     @end
  1406.           @openend:
  1407.              move.l  d6,a6                 { restore a6 }
  1408.              move.l  (sp)+,d2
  1409.           @end:
  1410.          end;
  1411. (*    if Errno = 0 then*)
  1412.     { No error, add file handle to linked list }
  1413.     { this must be checked before the call to  }
  1414.     { Error2InIOut since it resets Errno to 0  }
  1415. (*      AddToList(FileList,i);*)
  1416.     If Errno <> 0 then
  1417.        Error2InOut;
  1418.  
  1419.     filerec(f).handle:=i;
  1420.     if (flags and $10)<>0 then
  1421.        do_seekend(filerec(f).handle);
  1422.  
  1423. end;
  1424.  
  1425. {*****************************************************************************
  1426.                            UnTyped File Handling
  1427. *****************************************************************************}
  1428.  
  1429. {$i file.inc}
  1430.  
  1431. {*****************************************************************************
  1432.                            Typed File Handling
  1433. *****************************************************************************}
  1434.  
  1435. {$i typefile.inc}
  1436.  
  1437. {*****************************************************************************
  1438.                            Text File Handling
  1439. *****************************************************************************}
  1440.  
  1441. {$i text.inc}
  1442.  
  1443. {*****************************************************************************
  1444.                            Directory Handling
  1445. *****************************************************************************}
  1446.  
  1447. procedure mkdir(const s : string);[IOCheck];
  1448. var
  1449.   buffer : array[0..255] of char;
  1450.   j: Integer;
  1451.   temp : string;
  1452. begin
  1453.   { We must check the Ctrl-C before IOChecking of course! }
  1454.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  1455.    Begin
  1456.      { Clear CTRL-C signal }
  1457.      SetSignal(0,SIGBREAKF_CTRL_C);
  1458.      Halt(CTRL_C);
  1459.    end;
  1460.   If InOutRes <> 0 then exit;
  1461.   temp:=s;
  1462.   for j:=1 to length(temp) do
  1463.     if temp[j] = '\' then temp[j] := '/';
  1464.   move(temp[1],buffer,length(temp));
  1465.   buffer[length(temp)]:=#0;
  1466.   asm
  1467.         move.l  a6,d6
  1468.         { we must load the parameters BEFORE setting up the }
  1469.         { OS call with a6                                   }
  1470.         lea     buffer,a0
  1471.         move.l  a0,d1
  1472.         move.l  _DosBase,a6
  1473.         jsr     _LVOCreateDir(a6)
  1474.         tst.l   d0
  1475.         bne     @noerror
  1476.         jsr     _LVOIoErr(a6)
  1477.         move.w  d0,errno
  1478.         bra     @end
  1479. @noerror:
  1480.         { Now we must unlock the directory }
  1481.         { d0 = lock returned by create dir }
  1482.         move.l  d0,d1
  1483.         jsr     _LVOUnlock(a6)
  1484. @end:
  1485.         { restore base pointer }
  1486.         move.l  d6,a6
  1487.   end;
  1488.   If errno <> 0 then
  1489.     Error2InOut;
  1490. end;
  1491.  
  1492.  
  1493. procedure rmdir(const s : string);[IOCheck];
  1494. var
  1495.   buffer : array[0..255] of char;
  1496.   j : Integer;
  1497.   temp : string;
  1498. begin
  1499.   { We must check the Ctrl-C before IOChecking of course! }
  1500.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  1501.    Begin
  1502.      { Clear CTRL-C signal }
  1503.      SetSignal(0,SIGBREAKF_CTRL_C);
  1504.      Halt(CTRL_C);
  1505.    end;
  1506.   If InOutRes <> 0 then exit;
  1507.   temp:=s;
  1508.   for j:=1 to length(temp) do
  1509.     if temp[j] = '\' then temp[j] := '/';
  1510.   move(temp[1],buffer,length(temp));
  1511.   buffer[length(temp)]:=#0;
  1512.   do_erase(buffer);
  1513. end;
  1514.  
  1515.  
  1516.  
  1517. procedure chdir(const s : string);[IOCheck];
  1518. var
  1519.   buffer : array[0..255] of char;
  1520.   alock : longint;
  1521.   FIB :pFileInfoBlock;
  1522.   j: integer;
  1523.   temp : string;
  1524. begin
  1525.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  1526.    Begin
  1527.      { Clear CTRL-C signal }
  1528.      SetSignal(0,SIGBREAKF_CTRL_C);
  1529.      Halt(CTRL_C);
  1530.    end;
  1531.   If InOutRes <> 0 then exit;
  1532.   temp:=s;
  1533.   for j:=1 to length(temp) do
  1534.     if temp[j] = '\' then temp[j] := '/';
  1535.   { Return parent directory }
  1536.   if s = '..' then
  1537.   Begin
  1538.        getdir(0,temp);
  1539.        j:=length(temp);
  1540.        { Look through the previous paths }
  1541.        while (temp[j] <> '/') AND (temp[j] <> ':') AND (j > 0 ) do
  1542.          dec(j);
  1543.        if j > 0 then
  1544.          temp:=copy(temp,1,j);
  1545.   end;
  1546.   alock := 0;
  1547.   fib:=nil;
  1548.   new(fib);
  1549.  
  1550.   move(temp[1],buffer,length(temp));
  1551.   buffer[length(temp)]:=#0;
  1552.   { Changing the directory is a pretty complicated affair }
  1553.   {   1) Obtain a lock on the directory                   }
  1554.   {   2) CurrentDir the lock                              }
  1555.   asm
  1556.     lea      buffer,a0
  1557.     move.l   a0,d1      { pointer to buffer in d1  }
  1558.     move.l   d2,-(sp)   { save d2 register         }
  1559.     move.l   #-2,d2     { ACCESS_READ lock         }
  1560.     move.l   a6,d6      { Save base pointer        }
  1561.     move.l   _DosBase,a6
  1562.     jsr      _LVOLock(a6){ Lock the directory      }
  1563.     move.l   (sp)+,d2   { Restore d2 register      }
  1564.     tst.l    d0         { zero = error!            }
  1565.     bne      @noerror
  1566.     jsr      _LVOIoErr(a6)
  1567.     move.w   d0,errno
  1568.     move.l   d6,a6       { reset base pointer       }
  1569.     bra      @End
  1570.   @noerror:
  1571.     move.l   d6,a6       { reset base pointer       }
  1572.     move.l   d0,alock    { save the lock            }
  1573.   @End:
  1574.   end;
  1575.   If errno <> 0 then
  1576.    Begin
  1577.      Error2InOut;
  1578.      exit;
  1579.    end;
  1580.   if (Examine(alock, fib^) = TRUE) AND (fib^.fib_DirEntryType > 0) then
  1581.     Begin
  1582.       alock := CurrentDir(alock);
  1583.       if OrigDir = 0 then
  1584.         Begin
  1585.           OrigDir := alock;
  1586.           alock := 0;
  1587.         end;
  1588.     end;
  1589.   if alock <> 0 then
  1590.     Unlock(alock);
  1591.   if assigned(fib) then dispose(fib);
  1592. end;
  1593.  
  1594.  
  1595.  
  1596.  
  1597.   Procedure GetCwd(var path: string);
  1598.    var
  1599.      lock: longint;
  1600.      fib: PfileInfoBlock;
  1601.      len : integer;
  1602.      newlock : longint;
  1603.      elen : integer;
  1604.      Process : PProcess;
  1605.     Begin
  1606.      len := 0;
  1607.      path := '';
  1608.      fib := nil;
  1609.      { By using a pointer instead of a local variable}
  1610.      { we are assured that the pointer is aligned on }
  1611.      { a dword boundary.                             }
  1612.      new(fib);
  1613.      Process := FindTask(nil);
  1614.      if (process^.pr_Task.tc_Node.ln_Type = NT_TASK) then
  1615.        Begin
  1616.          path:='';
  1617.          exit;
  1618.        end;
  1619.      lock := DupLock(process^.pr_CurrentDir);
  1620.      if (Lock = 0) then
  1621.        Begin
  1622.          path:='';
  1623.          exit;
  1624.        end;
  1625.  
  1626.     While (lock <> 0) and (Examine(lock,FIB^) = TRUE) do
  1627.     Begin
  1628.          elen := strlen(fib^.fib_FileName);
  1629.          if (len + elen + 2 > 255) then
  1630.             break;
  1631.          newlock := ParentDir(lock);
  1632.          if (len <> 0) then
  1633.           Begin
  1634.             if (newlock <> 0) then
  1635.                path:='/'+path
  1636.             else
  1637.                path:=':'+path;
  1638.             path:=strpas(fib^.fib_FileName)+path;
  1639.             Inc(len);
  1640.           end
  1641.          else
  1642.           Begin
  1643.             path:=strpas(fib^.fib_Filename);
  1644.             if (newlock = 0) then
  1645.              path:=path+':';
  1646.           end;
  1647.  
  1648.            len := len + elen;
  1649.  
  1650.            UnLock(lock);
  1651.            lock := newlock;
  1652.     end;
  1653.     if (lock <> 0) then
  1654.     Begin
  1655.         UnLock(lock);
  1656.         path := '';
  1657.     end;
  1658.     if assigned(fib) then dispose(fib);
  1659.  end;
  1660.  
  1661.  
  1662. procedure getdir(drivenr : byte;var dir : string);
  1663. begin
  1664.   if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
  1665.     Begin
  1666.       { Clear CTRL-C signal }
  1667.       SetSignal(0,SIGBREAKF_CTRL_C);
  1668.       Halt(CTRL_C);
  1669.     end;
  1670.   GetCwd(dir);
  1671.   If errno <> 0 then
  1672.      Error2InOut;
  1673. end;
  1674.  
  1675.  
  1676. {*****************************************************************************
  1677.                          SystemUnit Initialization
  1678. *****************************************************************************}
  1679.  
  1680. Procedure Startup; Assembler;
  1681. asm
  1682.     move.l  a6,d6         { save a6             }
  1683.  
  1684.     move.l  (4),a6        { get ExecBase pointer }
  1685.     move.l  a6,_ExecBase
  1686.     suba.l  a1,a1
  1687.     jsr     _LVOFindTask(a6)
  1688.     move.l  d0,a0
  1689.     { Check the stack value }
  1690.  
  1691.     {   are we running from a CLI?             }
  1692.  
  1693.     tst.l   172(a0)         { 172 = pr_CLI     }
  1694.     bne     @fromCLI
  1695.  
  1696.     { we do not support Workbench yet ..       }
  1697.     move.l  d6,a6           { restore a6       }
  1698.     move.l  #1,d0
  1699.     jsr     HALT_ERROR
  1700.  
  1701. @fromCLI:
  1702.     {  Open the following libraries:            }
  1703.     {   Intuition.library                       }
  1704.     {   dos.library                             }
  1705.  
  1706.     moveq.l  #0,d0
  1707.     move.l   intuitionname,a1      { directly since it is a pchar }
  1708.     jsr      _LVOOpenLibrary(a6)
  1709.     move.l   d0,_IntuitionBase
  1710.     beq      @exitprg
  1711.  
  1712.     moveq.l  #0,d0
  1713.     move.l   utilityname,a1        { directly since it is a pchar }
  1714.     jsr      _LVOOpenLibrary(a6)
  1715.     move.l   d0,_UtilityBase
  1716.     beq      @exitprg
  1717.  
  1718.     moveq.l  #0,d0
  1719.     move.l   dosname,a1            { directly since it is a pchar }
  1720.     jsr      _LVOOpenLibrary(a6)
  1721.     move.l   d0,_DOSBase
  1722.     beq      @exitprg
  1723.  
  1724.     { Find standard input and output               }
  1725.     { for CLI                                      }
  1726. @OpenFiles:
  1727.     move.l  _DOSBase,a6
  1728.     jsr     _LVOInput(a6)        { get standard in                   }
  1729.     move.l  d0, StdInputHandle   { save standard Input handle        }
  1730. {    move.l  d0,d1               }{ set up for next call              }
  1731. {   jsr     _LVOIsInteractive(a6)}{ is it interactive?             }
  1732. {   move.l  #_Input,a0          }{ get file record again             }
  1733. {   move.b  d0,INTERACTIVE(a0)  }{ set flag                          }
  1734. {   beq     StdInNotInteractive }{ skip this if not interactive    }
  1735. {   move.l  BUFFER(a0),a1       }{ get buffer address                }
  1736. {   add.l   #1,a1               }{ make end one byte further on      }
  1737. {   move.l  a1,MAX(a0)          }{ set buffer size                   }
  1738. {   move.l  a1,CURRENT(a0)      }{ will need a read                  }
  1739.     bra     @OpenStdOutput
  1740. @StdInNotInteractive
  1741. {    jsr _p%FillBuffer     }      { fill the buffer                   }
  1742. @OpenStdOutput
  1743.     jsr     _LVOOutput(a6)      { get ouput file handle             }
  1744.     move.l  d0,StdOutputHandle  { get file record                   }
  1745.     bra     @startupend
  1746. {    move.l  d0,d1             }  { set up for call                   }
  1747. {    jsr _LVOIsInteractive(a6) }  { is it interactive?                }
  1748. {    move.l  #_Output,a0       }  { get file record                   }
  1749. {    move.b  d0,INTERACTIVE(a0)}  { set flag                          }
  1750. @exitprg:
  1751.      move.l d6,a6                 { restore a6                        }
  1752.      move.l #219,d0
  1753.      jsr    HALT_ERROR
  1754. @startupend:
  1755.      move.l d6,a6                 { restore a6                        }
  1756. end;
  1757.  
  1758.  
  1759.  
  1760. begin
  1761.   errno:= 0;
  1762.   FromHalt := FALSE;
  1763. {  Initial state is on -- in case of RunErrors before the i/o handles are }
  1764. {  ok.                                                                    }
  1765.   Initial:=TRUE;
  1766. { Initialize ExitProc }
  1767.   ExitProc:=Nil;
  1768.   Startup;
  1769. { to test stack depth }
  1770.   loweststack:=maxlongint;
  1771. { Setup heap }
  1772.   InitHeap;
  1773. { Setup stdin, stdout and stderr }
  1774.   OpenStdIO(Input,fmInput,StdInputHandle);
  1775.   OpenStdIO(Output,fmOutput,StdOutputHandle);
  1776.   { The Amiga does not seem to have a StdError }
  1777.   { handle, therefore make the StdError handle }
  1778.   { equal to the StdOutputHandle.              }
  1779.   StdErrorHandle := StdOutputHandle;
  1780.   OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  1781. { Now Handles and function handlers are setup }
  1782. { correctly.                                  }
  1783.   Initial:=FALSE;
  1784. { Reset IO Error }
  1785.   InOutRes:=0;
  1786. { Startup }
  1787.   { Only AmigaOS v2.04 or greater is supported }
  1788.   If KickVersion < 36 then
  1789.    Begin
  1790.      WriteLn('v36 or greater of Kickstart required.');
  1791.      Halt(1);
  1792.    end;
  1793.    argc:=GetParamCount(args);
  1794.    OrigDir := 0;
  1795.    FileList := nil;
  1796.    old_Exit:=exitproc;
  1797.    Exitproc:=@ExitCall;
  1798. end.
  1799.  
  1800.  
  1801. {
  1802.   $Log: sysamiga.pas,v $
  1803.   Revision 1.9  1998/08/17 12:34:22  carl
  1804.     * chdir accepts .. characters
  1805.     + added ctrl-c checking
  1806.     + implemented sbrk
  1807.     * exit code was never called if no error was found on exit!
  1808.     * register was not saved in do_open
  1809.  
  1810.   Revision 1.8  1998/07/13 12:32:18  carl
  1811.     * do_truncate works, some cleanup
  1812.  
  1813.   Revision 1.6  1998/07/02 12:37:52  carl
  1814.     * IOCheck for chdir,rmdir and mkdir as in TP
  1815.  
  1816.   Revision 1.5  1998/07/01 14:30:56  carl
  1817.     * forgot that includes are case sensitive
  1818.  
  1819.   Revision 1.4  1998/07/01 14:13:50  carl
  1820.     * do_open bugfix
  1821.     * correct conversion of Amiga error codes to TP error codes
  1822.     * InoutRes word bugfix
  1823.     * parameter counting fixed
  1824.     * new stack checking implemented
  1825.     + IOCheck for chdir,rmdir,getdir and rmdir
  1826.     * do_filepos was wrong
  1827.     + chdir correctly implemented
  1828.     * getdir correctly implemented
  1829.  
  1830.   Revision 1.1.1.1  1998/03/25 11:18:47  root
  1831.   * Restored version
  1832.  
  1833.   Revision 1.14  1998/03/21 04:20:09  carl
  1834.     * correct ExecBase pointer (from Nils Sjoholm)
  1835.     * correct OpenLibrary vector (from Nils Sjoholm)
  1836.  
  1837.   Revision 1.13  1998/03/14 21:34:32  carl
  1838.     * forgot to save a6 in Startup routine
  1839.  
  1840.   Revision 1.12  1998/02/24 21:19:42  carl
  1841.   *** empty log message ***
  1842.  
  1843.   Revision 1.11  1998/02/23 02:22:49  carl
  1844.     * bugfix if linking problems
  1845.  
  1846.   Revision 1.9  1998/02/06 16:34:32  carl
  1847.     + do_open is now standard with other platforms
  1848.  
  1849.   Revision 1.8  1998/02/02 15:01:45  carl
  1850.     * fixed bug with opening library versions (from Nils Sjoholm)
  1851.  
  1852.   Revision 1.7  1998/01/31 19:35:19  carl
  1853.     + added opening of utility.library
  1854.  
  1855.   Revision 1.6  1998/01/29 23:20:54  peter
  1856.     - Removed Backslash convert
  1857.  
  1858.   Revision 1.5  1998/01/27 10:55:04  peter
  1859.     * Amiga uses / not \, so change AllowSlash -> AllowBackSlash
  1860.  
  1861.   Revision 1.4  1998/01/25 21:53:20  peter
  1862.     + Universal Handles support for StdIn/StdOut/StdErr
  1863.     * Updated layout of sysamiga.pas
  1864.  
  1865.   Revision 1.3  1998/01/24 21:09:53  carl
  1866.     + added missing input/output function pointers
  1867.  
  1868.   Revision 1.2  1998/01/24 14:08:25  carl
  1869.     * RunError 217 --> RunError 219 (cannot open lib)
  1870.     + Standard Handle names implemented
  1871.  
  1872.   Revision 1.1  1998/01/24 05:12:15  carl
  1873.     + initial revision, some stuff still missing though.
  1874.       (and as you might imagine ... untested :))
  1875. }
  1876.